Shareware Grab Bag/Shareware Grab Bag.iso/001/tdial.arc/MENU.INC

Text File | 1985-09-23 | 9.5 KB | 348 lines

const
  menu_max_ent  = 20;             { Maximum number of entries per menu   }
                                  { May be modified as desired; if it is }
                                  { made larger, the length of type SSTR }
                                  { should be increased as well          }
type
  menu_str    = string[80];
  menu_sstr   = string[20];

       { This is the description of one entry in a menu }
  menu_entry = record
         short_name  : menu_sstr;
         description : menu_str;
         return_val  : char;
         start_pos   : integer;
         end;

       { This is the complete description of a menu. The ENTRY array uses
         dynamically allocated variables to reduce the amount of wasted
         memory space. }
  menu_list_type = record
         xline1, yline1,
         xline2, yline2,
         blanks, entries
                   : integer;
         unique    : menu_sstr;
         entry     : array[1..menu_max_ent] of ^menu_entry;
         end;

procedure ReverseVid;

   begin
      textcolor(tb5);
      textbackground(tc5);
   end;

procedure NormVid;

   begin
      textcolor(tc5);
      textbackground(tb5);
   end;

procedure HighVid;

   begin
      textcolor(fc5);
      textbackground(tb5);
   end;

procedure menu_init(var menu:menu_list_type; spacing,x1,y1,x2,y2:integer);
 { Initialize a Menu }
var x : integer;
begin
  with menu do begin
    entries   := 0;
    unique    := '';
    xline1    := x1;
    yline1    := y1;
    xline2    := x2;
    yline2    := y2;
    blanks    := spacing;
    for x := 1 to menu_max_ent do
      entry[x] := nil;
    end; (* with *)
end; (* proc menu_init *)

procedure menu_clr(var menu:menu_list_type);
 { Clear a menu after use
   DO NOT use this on a menu before the menu has been initialized!! }
var
  x : integer;
begin
  with menu do begin
    for x := 1 to entries do
      if entry[x] <> nil then begin
        dispose(entry[x]);
        entry[x] := nil;
        end;
    entries := 0;
    unique  := '';
    end; (* with *)
end; (* proc menu_clr *)

function menu_srch(menu:menu_list_type;
                   srch:menu_sstr; srch_type:integer):integer;
 { search a menu.
   SRCH_TYPE = 1 means to search for the short name SRCH
   SRCH_TYPE = 2 means to search for the return value SRCH[1]
   SRCH_TYPE = 3 means to search for the first character of SRCH as the first
                 character of SHORT_NAME
   return the appropriatte subscript if SRCH is found, otherwise zero }
var
  x : integer;
begin
  x := 1;
  with menu do begin
    case srch_type of
      1 : {search for srch=short_name[x]}
          while ((x<=entries) and (srch<>entry[x]^.short_name)) do
            x := x + 1;
      2 : {search for srch=return_val[x]}
          if srch = '' then
            x := 0
          else
            while ((x<=entries) and (srch[1]<>entry[x]^.return_val)) do
              x := x + 1;
      3 : {search for srch[1]=short_name[x,1]}
          while ((x<=entries) and
                 (copy(srch,1,1)<>copy(entry[x]^.short_name,1,1))) do
            x := x + 1;
      else
          x := 0;
      end; (* case*)
    if x > entries then
      x := 0;
    end; (* with *)
    menu_srch := x;
end; (* func menu_srch *)

procedure menu_add(var menu:menu_list_type;
                   sname:menu_sstr; desc:menu_str; rtval:char);
 { Add an entry to a menu.
   If the menu already has the maximum allowable entries, issue a message
   and halt the system.
   Add 1 to the number of entries and move the short name, description,
   and return value to the menu array. Set the START_POS for this entry
   so that it will be seperated from its predecessor by the proper space }
var
  p : integer;
begin
  if menu.entries = menu_max_ent then begin
    writeln;
    writeln('attempt to add too many entries to menu');
    writeln(sname,' / ',desc,' / ',rtval);
    writeln('System Halting');
    halt;
    end;
  while ((sname<>'') and (sname[1]=' ')) do
    delete(sname,1,1);
  if sname = '' then
    sname := '***';
  if rtval = ' ' then
    rtval := copy(sname,1,1);
  with menu do begin
    p := pos(sname[1],unique);
    if p > 0 then
      insert(sname[1],unique,p)
    else
      unique := unique + sname[1];
    entries := entries + 1;
    new(entry[entries]);
    with entry[entries]^ do begin
      short_name   := sname;
      description  := desc;
      return_val   := rtval;
      if entries = 1 then
        start_pos := menu.xline1
      else
        start_pos := entry[entries-1]^.start_pos +
                     length(entry[entries-1]^.short_name) +
                     blanks;
      end; (* with *)
    end; (* with *)
end; (* proc menu_add *)

procedure menu_finalize(var menu:menu_list_type);
 { Finalize the format of a menu.
   This procedure performs the following operations:
      * make a list of the unique first characters of the short names
      * if the short names will not fit on one line with the specified
        spacing, shrink the spacing to make the menu fit
      * if the short names can't be made to fit, issue a message and HALT. }
label exit;
var
  line_length,
  menu_length,
  spacing,
  x, y   : integer;

  procedure delete_dups(ch:char; var list:menu_sstr);
  var
    p : integer;
  begin
    p := pos(ch,list);
    while p > 0 do begin
      delete(list,p,1);
      p := pos(ch,list);
      end;
  end; (* proc delete_dups *)

begin
  with menu do begin
    if entries < 2 then
      goto exit;
    x := 1;
    while x < length(unique) do begin
      y := x+1;
      while y <= length(unique) do
        if unique[x] = unique[y] then
          delete_dups(unique[x], unique)
        else
          y := y + 1;
      x := x + 1;
      end;
    line_length := 80 - xline1;
    with entry[entries]^ do
      if start_pos + length(short_name) <= line_length then
        goto exit;
    menu_length := 0;
    for x := 1 to entries do
      menu_length := menu_length + length(entry[x]^.short_name);
    blanks := (line_length - menu_length) div entries;
    if blanks < 1 then begin
      writeln;
      writeln('Menu short names are too long to fit on one line.');
      for x := 1 to entries do
        write(entry[x]^.short_name,' ');
      writeln;
      writeln('System Halting');
      halt;
      end
    else
      for x := 2 to entries do
        entry[x]^.start_pos := entry[x-1]^.start_pos +
                               length(entry[x-1]^.short_name) + blanks;
    end; (* with *)
exit:
end; (* proc menu_finalize *)

function menu_exec(menu:menu_list_type; current:integer):char;
{ This is the procedure which actually displays and processes the menu.
  The argument CURRENT is an integer which specifies which entry should
  be high-lighted at the start (the default). }
const
  home_key = #199;
  end_key  = #207;
  left     = #203;
  right    = #205;
  return   = #13;
  tab      = #9;
  back_tab = #143;
  pg_up    = #201;
  pg_dn    = #209;
  escape   = #27;
var
  ch   : char;
  x,
  new  : integer;

  procedure menu_write(x,y:integer; marked:boolean; s:menu_sstr);
  var
    savex,
    savey : integer;
  begin
    savex := wherex;
    savey := wherey;
    gotoxy(x,y);
    if marked then begin
      ReverseVid;
      write(s);
      HighVid;
      end
    else begin
      HighVid;
      write(s);
      end;
    gotoxy(savex,savey);
  end; (* proc menu_write *)

begin
  HighVid;
  if current < 1 then
    current := 1;
  if current > menu.entries then
    current := menu.entries;
  gotoxy(menu.xline2, menu.yline2); clreol;
  gotoxy(menu.xline1, menu.yline1); clreol;
  for x := 1 to menu.entries do
    with menu.entry[x]^ do begin
      gotoxy(start_pos,menu.yline1);
      write(short_name);
      end;
  repeat
    with menu.entry[current]^ do begin
      menu_write(start_pos,menu.yline1,true,short_name);
      gotoxy(menu.xline2, menu.yline2); clreol;
      NormVid;
      write(description);
      repeat
        read(kbd,ch);
        if keypressed then begin
          read(kbd,ch);
          if ord(ch) < 128 then
            ch := chr(ord(ch)+128);
          end;
      until pos(ch,return+left+tab+right+back_tab+home_key+pg_up+end_key+pg_dn
                   +escape+menu.unique) > 0;
      if pos(ch,menu.unique)>0 then begin
        gotoxy(wherex-1,wherey);
        write(' ');
        new := menu_srch(menu,ch+'',3);
        current := new;
        gotoxy(menu.xline2, menu.yline2); clreol;
        write(menu.entry[current]^.description);
        ch := return;
        end;
      menu_write(start_pos, menu.yline1, false, short_name);
      end; (* with *)
    case ch of
      pg_up,
      home_key : current := 1;
      pg_dn,
      end_key  : current := menu.entries;
      back_tab,
      left     : current := current - 1;
      tab,
      right    : current := current + 1;
      escape   : begin
                 menu_exec := ' ';
                 ch := return;
                 end;
      return   : menu_exec := menu.entry[current]^.return_val;
      else;
      end; (* case *)
    if current < 1 then
      current := menu.entries
    else
    if current > menu.entries then
      current := 1;
  until ch = return;
  NormVid;
end; (* func menu_exec *)

procedure EraseMenu;

   var
      i  :  integer;

   begin
      for i := 1 to 2 do
         begin
            gotoxy(1,i);
            clreol;
         end;
      gotoxy(1,1);
      NormVid;
   end;